perm filename QUAD.F4[MUS,LCS]2 blob sn#098757 filedate 1974-04-23 generic text, type T, neo UTF8
00010	C  QUAD CALL MUST BE IN 1ST OF 5 PARAMS.  QUAD MUST BE FOLLOWED
00016	C   BY SPC, / OR ;.  OTHER CALLS SUCH AS MOVE,NUM ETC. CAN
00022	C   APPEAR BEFORE  / OR ;, BUT "ALL" MUST! APPEAR 
00028	C   BEFORE! QUAD (IF USED).
00030	C  *** THE 5TH PARAM MUST NOT!! BE LISTED AT ALL IN YOUR SCORE!!! ****
00034	C  ADD AN "F" TO QUAD FOR FUNCTIONS, AN "X" FOR X,Y COORDS.
00040	C BASIC QUAD PRODUCES CIRCLES. /DEGS/RADIUS/CENT. X/CENT. Y/
00046	C  QUADX -- /X /Y / (5TH PARAM WILL ALWAYS BE WASTED)
00052	CC43611	IF(N.NE.'Q'.OR.INP(JD+1).NE.'U')GO TO 4361
00058	CC	QX=-13.
00064	CC	DO 43612 N=JD,72
00070	CC	J=INP(N)
00076	CC	IF(J.EQ.IXX)QX=QX-1.
00082	CC	IF(J.EQ.IF)QX=QX-2.
00100		SUBROUTINE QUAD(NL)
00200		COMMON P(30),INUM,IPAR,CNT(27),BT,PL(48),IREST,DF,DUR(27)
00300	C   INUM=INST#  IPAR=PARAM#  
00320	C   BT=BASIC TIME P1 WHEN SUBROUTINE IS CALLED
00400	C   IF IREST IS <0, THAT NOTE WILL BE A REST.  
00500	C   INST=INST. NAME,  BG=INSTS' BEGIN TIMES.
00600	C   NOTE #S IN SUBROUTINE: (1-84)  
00620	C   C4=37  FS4=43  C5=49  ETC.    F1=86  F15=100 (NO F16!)
00700	
00800		DIMENSION F(4,512),IP(1),ISU(1000),ALF(4),PATH(2,512),
00820		1 ICA(4),ICB(4),ARY(9)
00900	       DATA ICA/-106,90,90,-106/,
01000		1 ICB/90,90,-106,-106/,ALF/'A','B','C','D'/
01050		1 , ARY/45H(' ARRAY F',I2,'(512); SEG(F',I2,');0  999')  /
01055	C  /DEG OR X/DIS OR Y/CEN OF CIRC X/CEN OF CIRCLE Y/(CALLS QUAD)/
01200		IF(CNT(INUM).GT.1.)GO TO 1
01400		L=0
01420		ARY(3)=5H',I1,
01500		NJ=IPAR-4
01525		XF=999.
01550		DIF=0
01575		DURFAC=(DUR(INUM)-P(1))/512.
01587	C  WON'T CREATE FUNCS OF DPY FOR MORE THAN 1 INST
01595	1	CALL QUADO(P,IPAR,NL,XF,YF)
01600		DIF=DIF+P(2)
01610		IF(DIF)RETURN
01620	C   GET ANOTHER NNTE FOR THIS FUNC. SLOT
01630	3	L=L+1
01800		M=0
01900		DO 4 K=NJ,IPAR-1
02000		M=M+1
02100	4	F(M,L)=P(K)
02200		PATH(1,L)=XF
02300		PATH(2,L)=YF
02400		IF(L.EQ.512)GO TO 2
02410		DIF=DIF-DURFAC
02420		IF(DIF.GE.0)GO TO 3
02430	C   USE ANOTHER FUNC. SLOT FOR THIS NOTE
02440		RETURN
02450	C   DUR SHOULD BE SET CLOSE TO "TRUE" DUR.
02500	2	CALL DPYSET(1,ISU,1000)
02600		CALL DPYBRT(2)
02700		CALL TYPLOC(150,-220)
02800		I=210
02900		J=506
03000		LB=250
03100		DO 5 K=1,2
03200		L=256
03300		IB=236
03400		JB=456
03500		DO 6 M=1,2
03600		CALL ALINE(I,L,J,L)
03700	C   HORIZANTAL LINES
03800		CALL ALINE(LB,IB,LB,JB)
03900	C   VERTICAL LINES
03910		DO 7 KB=LB+192,LB+64,-64
03920	7	CALL ALINE(KB,L,KB,IB)
03930	C   SPACE MARKERS ON FUNC DPYS.
04000		L=-440
04100		IB=-460
04200	6	JB=-240
04300		LB=-466
04400		I=-486
04500	5	J=-210
04600	
04700	CQ55	I=-480
04800	CQ	J=460
04900	CQ	DO 7 K=0,3
05000	CQ	CALL DPYTXT(I,J,JF(K+1),1)
05100	CQ	I=I+700
05200	CQ	IF(K.NE.1)GO TO 7
05300	CQ	I=-480
05400	CQ	J=-J
05500	CQ7	CONTINUE
05600		CALL ALINE(-200,-200,200,200)
05700		CALL ALINE(-200,200,200,-200)
05750	C   MARKS LISTENER POS.
05763	
05776		A=6.
05789		L=0
05797		I=141.4
05801		J=-1
05805	140	IB=141.4*SIND(A)
05810		JB=141.4*COSD(A)
05812		IF(J.GE.0)GO TO 141
05815		CALL ALINE(L,I,IB,JB)
05820	141	A=A+6.
05821		J=J-1
05822		L=IB
05823		I=JB
05825		IF(A.LT.360.)GO TO 140
05830	C   THE SPEAKER CIRCLE
05835	
05895		CALL DPYBRT(5)
05897		CALL DPYBIG(5)
05900		DO 14 K=1,4
06000	14	CALL DPYTXT(ICA(K),ICB(K),ALF(K),1)
06100	
06200		CALL DPYOUT(1)
06400	
06500	77	M=1
06600		IB=-466
06700		J=256
06800		DO 8 K=NJ,IPAR-1
06900		CALL AIVECT(IB,IFIX(F(M,1)*200.0)+J)
07000		DO 9 L=4,512,3
07100		I=IB+L/2
07200	C   REDUCES TO FIT 1/4 OF SCREEN
07300		JB=F(M,L)*200.0+J
07400	99	CALL AVECT(I,JB)
07500	9	LB=0
07600		M=M+1
07700		IB=250
07800		IF(M.EQ.3)J=-440
07900		IF(M.EQ.4)IB=-466
08000	8	CONTINUE
08100	
08200	CQ	CALL DPYOUT(1)
08400		CALL AIVECT(IFIX(PATH(1,1)*10.0),IFIX(PATH(2,1)*10.0))
08500		DO 13 K=4,512,3
08600		I=PATH(1,K)*10.
08700		JB=PATH(2,K)*10.
08800		IF(IABS(JB).GT.512.OR.IABS(I).GT.512)GO TO 13
08900		CALL AVECT(I,JB)
09000	13	CONTINUE
09100		CALL DPYOUT(1)
09300		TYPE 112
09400		ACCEPT 113,NAME,LB
09420	333	IF(NAME.NE.'PLOT')GO TO 130
09440	C   JUMP IF NOT SAVING DPY BUFFER
09460		IP(1)=IP(3)+2
09480	C   IP(3) IS REALLY ISU(2).  I.E. WDCNT
09490		CALL SAVB(IP)
09495	C   WRITES A BINARY FILE OF DPY BUFFER FOR "PLTVEC"
09500	130	IF(NAME.EQ.' '.OR.MOD(NL,2).NE.0)RETURN
09510	C  RETURN IF QUAD OR QUADX(-13,-15)
09520	C  WRITE FUNCS IF QUADF OR QUADFX (-14,-16)
09600		REWIND  23
09700		CALL OFILE(23,NAME)
09800		DO 10 K=1,4
09900		IF(NJ.GE.10)ARY(3)=5H',I2,
10000		WRITE(23,ARY)NJ,NJ
10300	101	WRITE(23,12)(F(K,N),N=1,512)
10400	10	NJ=NJ+1
10500		END FILE 23
10520		TYPE 114,NAME
10600		RETURN
10900	12	FORMAT(16F8.5/)
11000	112	FORMAT(' TYPE OUTPUT FILE NAME'/)
11100	113 	FORMAT(A5,I)
11120	114	FORMAT(' FUNCTIONS ARE IN ',A5,'.DAT'/)
11200		END